VERSION 5.00
Begin VB.UserControl OwnerDrawListBox 
   ClientHeight    =   540
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1305
   ClipControls    =   0   'False
   HasDC           =   0   'False
   ScaleHeight     =   540
   ScaleWidth      =   1305
   ToolboxBitmap   =   "DrawItem.ctx":0000
   Begin VB.ListBox lstMain 
      Height          =   390
      IntegralHeight  =   0   'False
      ItemData        =   "DrawItem.ctx":00FA
      Left            =   45
      List            =   "DrawItem.ctx":00FC
      Style           =   1  'Checkbox
      TabIndex        =   0
      Top             =   45
      Width           =   1200
   End
End
Attribute VB_Name = "OwnerDrawListBox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'***************************************************************
Option Explicit
'Event Declarations:
Event Click() 'MappingInfo=lstMain,lstMain,-1,Click
Event DblClick() 'MappingInfo=lstMain,lstMain,-1,DblClick
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=lstMain,lstMain,-1,KeyDown
Event KeyPress(KeyAscii As Integer) 'MappingInfo=lstMain,lstMain,-1,KeyPress
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=lstMain,lstMain,-1,KeyUp
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=lstMain,lstMain,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=lstMain,lstMain,-1,MouseMove
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=lstMain,lstMain,-1,MouseUp
Event Scroll() 'MappingInfo=lstMain,lstMain,-1,Scroll
Event Resize() 'MappingInfo=UserControl,UserControl,-1,Resize

Private m_SubClassMain As SubClassData
Private m_lstMainhWnd As Long
Private m_Pictures As VBA.Collection
Private m_fDesign As Boolean
Private Const SysColorBit As Long = &H80000000

'Cache system colors
Private Enum GDIColors
    clrWindowText
    clrWindow
    clrHighlight
    clrHighlightText
    clrLastPen = clrWindowText
    clrLastBrush = clrHighlight
End Enum

Private m_Colors(0 To 4) As Long
Private m_hGDIObjects(0 To 3) As Long
Private m_YUnitHimetric As OLE_YPOS_HIMETRIC

Friend Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_DRAWITEM
            'lParam for this message is actually a
            'pointer to a DRAWITEMSTRUCT, deref the data.
            With g_DerefDrawItemStruct
                .Owner.SA.pvData = lParam
                If HandleDrawItem(.pSA(0)) Then
                    'Don't let this drop through to VB's window proc
                    'Falling through will redraw with a checkbox
                    WindowProc = 1
                    Exit Function
                End If
            End With
        Case WM_SYSCOLORCHANGE
            ResetWindowColors
    End Select
    WindowProc = CallWindowProc(m_SubClassMain.wndprocNext, hWnd, uMsg, wParam, lParam)
End Function

Private Function HandleDrawItem(pDIS As DRAWITEMSTRUCT) As Boolean
    If pDIS.hwndItem <> m_lstMainhWnd Then Exit Function
    'Copy the original rectangle
    'If pDIS.itemID = -1 then there are no items
    'in the list, don't try to draw a bitmap
    If Not pDIS.itemID Then
        'This will change rcItem.Left
        'so DrawItemText is positioned correctly
        DrawItemPicture pDIS, pDIS.rcItem
    End If
    'FillRect pDIS.hdc, pDIS.rcItem, SelectObject(hdc, GDIObjects(clrWindow))
    'Draw the text for the item
    DrawItemText pDIS
    'Draw the focus rectangle if necessary
    DrawFocus pDIS
    HandleDrawItem = True
End Function

Private Sub DrawItemPicture(pDIS As DRAWITEMSTRUCT, prc As RECT)
Const TextOffset = 3
Dim Pic As IPicture
    If pDIS.itemAction And (ODA_SELECT Or ODA_DRAWENTIRE) Then
        VBoost.Assign Pic, pDIS.ItemData
        If Not Pic Is Nothing Then
            With prc
                'Render has some really weird requirements.
                'y argument, subtract 1
                'cy argument, negative
                'ySrc argument, Himetric value for 1 (not 0)
                Pic.Render pDIS.hdc, .Left, .Bottom - 1, _
                  .Bottom - .Top, .Top - .Bottom, _
                  0, m_YUnitHimetric, _
                  Pic.Width, Pic.Height, ByVal 0&
            End With
            VBoost.AssignZero Pic
        End If
    End If
    With prc
        .Left = .Left + .Bottom - .Top + TextOffset
    End With
End Sub

Private Sub DrawItemText(pDIS As DRAWITEMSTRUCT)
Dim hBrushOld, hPenOld
Dim clrText As GDIColors, clrBack As GDIColors
Dim hdc As Long
Dim strItem As String, cbItem As Integer
    hdc = pDIS.hdc
    If pDIS.itemAction And ODA_SELECT Then
        Exit Sub
    Else 'If pDIS.itemAction And (ODA_FOCUS Or ODA_DRAWENTIRE) Then
        'This could all be done with less code, but more API calls.
        'Until we can short circuit, use this approach. (LB_GETCARENTINDEX is an API call).
        If pDIS.itemID = -1 Then
            clrBack = clrWindow
            clrText = clrWindowText
        ElseIf pDIS.itemState And ODS_FOCUS Then
            clrBack = clrHighlight
            clrText = clrHighlightText
        ElseIf m_lstMainhWnd = GetFocus Then
            clrBack = clrWindow
            clrText = clrWindowText
        Else
            If pDIS.itemID = DoMsg(LB_GETCARETINDEX) Then
                clrBack = clrHighlight
                clrText = clrHighlightText
            Else
                clrBack = clrWindow
                clrText = clrWindowText
            End If
        End If
        SetTextColor hdc, m_Colors(clrText)
        SetBkColor hdc, m_Colors(clrBack)
        hBrushOld = SelectObject(hdc, GDIObjects(clrBack))
        hPenOld = SelectObject(hdc, GetStockObject(NULL_PEN))
        With pDIS.rcItem
            Rectangle hdc, .Left, .Top, .Right + 1, .Bottom + 1
        End With
        'Clean up hDC
        SelectObject hdc, hBrushOld
        SelectObject hdc, hPenOld
    End If
    If Not pDIS.itemID Then
        'Get the string from the VB listbox
        If Not pDIS.itemID Then strItem = lstMain.List(pDIS.itemID)
        'DrawText with GPF with a NULL pointer, use a zero length
        'string instead. StrPtr is the only way to see the difference.
        If StrPtr(strItem) = 0 Then strItem = ""
        With pDIS.rcItem
            .Left = .Left + 1
            DrawText hdc, strItem, -1, pDIS.rcItem, _
                    DT_VCENTER Or DT_LEFT Or DT_SINGLELINE Or DT_NOPREFIX Or DT_NOCLIP
            .Left = .Left - 1
        End With
    End If
End Sub

Private Sub DrawFocus(pDIS As DRAWITEMSTRUCT)
    If pDIS.itemAction And (ODA_FOCUS Or ODA_DRAWENTIRE) Then
        If pDIS.itemState And ODS_FOCUS Then
            If m_lstMainhWnd = GetFocus Then
                DrawFocusRect pDIS.hdc, pDIS.rcItem
            End If
        End If
    End If
End Sub

Private Property Get GDIObjects(hGDI As GDIColors) As Long
Dim pLogBrush As LOGBRUSH
    If m_hGDIObjects(hGDI) = 0 Then
        Select Case hGDI
            Case Is <= clrLastPen
                m_hGDIObjects(hGDI) = CreatePen(PS_SOLID, 1, m_Colors(hGDI))
            Case Is <= clrLastBrush
                With pLogBrush
                    .lbStyle = BS_SOLID
                    .lbColor = m_Colors(hGDI)
                End With
                m_hGDIObjects(hGDI) = CreateBrushIndirect(pLogBrush)
        End Select
    End If
    GDIObjects = m_hGDIObjects(hGDI)
End Property

Private Function ResetWindowColors(Optional fClearOnly As Boolean = False)
Dim i%
    For i% = 0 To 3
        If m_hGDIObjects(i%) Then DeleteObject m_hGDIObjects(i%)
        m_hGDIObjects(i%) = 0
    Next i%
    If Not fClearOnly Then
        If BackColor And SysColorBit Then BackColor = BackColor
        If ForeColor And SysColorBit Then ForeColor = ForeColor
        m_Colors(clrHighlight) = GetSysColor(COLOR_HIGHLIGHT)
        m_Colors(clrHighlightText) = GetSysColor(COLOR_HIGHLIGHTTEXT)
    End If
End Function

Private Function ResetGDIColor(Index As GDIColors, ByVal NewColor As OLE_COLOR)
    If m_hGDIObjects(Index) Then DeleteObject m_hGDIObjects(Index)
    m_hGDIObjects(Index) = 0
    If NewColor And SysColorBit Then
        NewColor = GetSysColor(NewColor Xor SysColorBit)
    End If
    m_Colors(Index) = NewColor
End Function

Private Function DoMsg(ByVal uMsg As Long, Optional ByVal wParam As Long, Optional ByVal lParam As Long) As Long
    DoMsg = CallWindowProc(m_SubClassMain.wndprocNext, m_lstMainhWnd, uMsg, wParam, lParam)
End Function

Private Sub UserControl_AmbientChanged(PropertyName As String)
    If m_fDesign Then
        If PropertyName = "DisplayName" Then
            lstMain.Clear
            lstMain.AddItem Ambient.DisplayName
        End If
    End If
End Sub

Private Sub NoPropertySheet()
    'To keep a property out of both the locals window and the
    'property sheet, check the 'Don't show in Property Browser'
    'attribute, available on the Advanced tab of the Tools/Procedure
    'Attributes dialog.  To stop the item from showing in the
    'property sheet, but still support it in the locals window,
    'use this approach.
    
    'If you stop on this error, then right click on the
    'code pane and choose Toggle/Break on Unhandled Errors.
    'You can set the default for this setting in the Tools/Options
    'dialog on the General tab.
    If m_fDesign Then Err.Raise 394 'GetNotSupported error
End Sub

Private Sub SetDesignMode()
    On Error Resume Next
    m_fDesign = Not Ambient.UserMode
    If Err Then m_fDesign = True
    On Error GoTo 0
End Sub

Private Sub UserControl_Initialize()
    Set m_Pictures = New VBA.Collection
    ResetWindowColors
End Sub

Private Sub UserControl_InitProperties()
    InitializeMode
End Sub

Public Sub AddItem(Item As String, Optional Picture As Picture, Optional Index As Integer = -1)
Dim pPic As Long
Dim IPic As IPicture
    If Not Picture Is Nothing Then
        'Get the IPicture interface from
        'Picture object.  IPicture has
        'a Render method, which we'll
        'use to draw the bitmap, icon,
        'or metafile in the list.
        Set IPic = Picture
        VBoost.Assign pPic, IPic 'ObjPtr(IPic) without AddRef/Release
        'Add pic if not in the collection
        On Error Resume Next
        m_Pictures.Item CStr(pPic)
        If Err Then
            m_Pictures.Add IPic, CStr(pPic)
        End If
        On Error GoTo 0
    End If
    With lstMain
        If Index = -1 Then
            .AddItem Item
        Else
            .AddItem Item, Index
        End If
        If pPic Then
            .ItemData(.NewIndex) = pPic
        End If
    End With
End Sub

Private Sub UserControl_Resize()
    With UserControl
        lstMain.Move 0, 0, .ScaleWidth, .ScaleHeight
    End With
    RaiseEvent Resize
End Sub

Private Sub UserControl_Terminate()
    If Not m_fDesign Then
        ResetWindowColors True
        UnSubClass m_SubClassMain, UserControl.hWnd
    End If
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
  BackColor = lstMain.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  lstMain.BackColor = New_BackColor
  PropertyChanged "BackColor"
  ResetGDIColor clrWindow, New_BackColor
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
  ForeColor = lstMain.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
  lstMain.ForeColor = New_ForeColor
  PropertyChanged "ForeColor"
  ResetGDIColor clrWindowText, New_ForeColor
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
  Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
  UserControl.Enabled() = New_Enabled
  PropertyChanged "Enabled"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,Font
Public Property Get Font() As Font
  Set Font = lstMain.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
  Set lstMain.Font = New_Font
  PropertyChanged "Font"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,Refresh
Public Sub Refresh()
  lstMain.Refresh
End Sub

Private Sub lstMain_Click()
  RaiseEvent Click
End Sub

Private Sub lstMain_DblClick()
  RaiseEvent DblClick
End Sub

Private Sub lstMain_KeyDown(KeyCode As Integer, Shift As Integer)
  RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub lstMain_KeyPress(KeyAscii As Integer)
  RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub lstMain_KeyUp(KeyCode As Integer, Shift As Integer)
  RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub lstMain_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  RaiseEvent MouseDown(Button, Shift, x, y)
End Sub

Private Sub lstMain_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  RaiseEvent MouseMove(Button, Shift, x, y)
End Sub

Private Sub lstMain_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  RaiseEvent MouseUp(Button, Shift, x, y)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,WhatsThisHelpID
Public Property Get WhatsThisHelpID() As Long
  WhatsThisHelpID = lstMain.WhatsThisHelpID
End Property

Public Property Let WhatsThisHelpID(ByVal New_WhatsThisHelpID As Long)
  lstMain.WhatsThisHelpID() = New_WhatsThisHelpID
  PropertyChanged "WhatsThisHelpID"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,TopIndex
Public Property Get TopIndex() As Integer
  NoPropertySheet
  TopIndex = lstMain.TopIndex
End Property

Public Property Let TopIndex(ByVal New_TopIndex As Integer)
  lstMain.TopIndex() = New_TopIndex
  PropertyChanged "TopIndex"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,ToolTipText
Public Property Get ToolTipText() As String
  ToolTipText = lstMain.ToolTipText
End Property

Public Property Let ToolTipText(ByVal New_ToolTipText As String)
  lstMain.ToolTipText() = New_ToolTipText
  PropertyChanged "ToolTipText"
End Property

Private Sub lstMain_Scroll()
  RaiseEvent Scroll
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,RemoveItem
Public Sub RemoveItem(Index As Integer)
  lstMain.RemoveItem Index
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,NewIndex
Public Property Get NewIndex() As Integer
  NoPropertySheet
  NewIndex = lstMain.NewIndex
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,ListIndex
Public Property Get ListIndex() As Integer
  NoPropertySheet
  ListIndex = lstMain.ListIndex
End Property

Public Property Let ListIndex(ByVal New_ListIndex As Integer)
  lstMain.ListIndex() = New_ListIndex
  PropertyChanged "ListIndex"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,ListCount
Public Property Get ListCount() As Integer
  NoPropertySheet
  ListCount = lstMain.ListCount
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,List
Public Property Get List(Index As Integer) As String
  NoPropertySheet
  List = lstMain.List(Index)
End Property

Public Property Let List(Index As Integer, ByVal New_List As String)
  lstMain.List(Index) = New_List
  PropertyChanged "List"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,hWnd
Public Property Get hWnd() As Long
  NoPropertySheet
  hWnd = UserControl.hWnd
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lstMain,lstMain,-1,Clear
Public Sub Clear()
  lstMain.Clear
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Dim Index As Integer

  BackColor = PropBag.ReadProperty("BackColor", vbWindowBackground)
  ForeColor = PropBag.ReadProperty("ForeColor", vbWindowText)
  UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
  Set lstMain.Font = PropBag.ReadProperty("Font", Ambient.Font)
  lstMain.WhatsThisHelpID = PropBag.ReadProperty("WhatsThisHelpID", 0)
  InitializeMode
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Dim Index As Integer

  Call PropBag.WriteProperty("BackColor", lstMain.BackColor, vbWindowBackground)
  Call PropBag.WriteProperty("ForeColor", lstMain.ForeColor, vbWindowText)
  Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
  Call PropBag.WriteProperty("Font", lstMain.Font, Ambient.Font)
  Call PropBag.WriteProperty("WhatsThisHelpID", lstMain.WhatsThisHelpID, 0)
  Call PropBag.WriteProperty("ToolTipText", lstMain.ToolTipText, "")
End Sub

Private Sub InitializeMode()
    SetDesignMode
    If m_fDesign Then
        On Error Resume Next
        lstMain.AddItem Ambient.DisplayName
    Else
        SubClass m_SubClassMain, UserControl.hWnd, ObjPtr(Me), AddressOf RedirectODLBWindowProc
        m_lstMainhWnd = lstMain.hWnd
        m_YUnitHimetric = UserControl.ScaleY(1, vbPixels, vbHimetric)
    End If
End Sub
